perm filename HOMER.F4[P11,LCS]1 blob
sn#589308 filedate 1981-05-26 generic text, type T, neo UTF8
C***** HOMER, PLACE
C****** FOR 'HOMING' OF BEAMS, SLURS, AND CHORD NOTES ***********
SUBROUTINE HOMER
COMMON /STF/RSTFAC(8),RSTJ2
COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /POSI/STFF(8),JJ2,POS
COMMON /XRN/RN(1) /PTR/PWDS(2) /LIMIT/LIM,ITEM,L,I,IX
1 /RMOD/RMODE2,RSET4,IBEAM,NOSET,STEM,STUP,NTC,ENDP,RAD,RDD
COMMON/ALF/QQ(3),K,RA,RB,N,RG,M,X,RE,RF,A,B,DISX,INP(58)
EQUIVALENCE (R3,RJQ(1)),(R6,RJQ(4)),(J11,JQ(9))
1,(R7,RJQ(5)),(R9,RJQ(7)),(R11,RJQ(9)),(R13,RJQ(11))
1,(J10,JQ(8)),(R8,RJQ(6)),(J7,JQ(5))
IF(JA.EQ.6)GO TO 9
IF(R13.NE.0)GO TO 10
C FOR GENL HOMING; WORDS; BEAMS; (STEMS HOMING IN HOMX.F4)
C 2.44 = WIDTH OF NOTE -- NEEDED BECAUSE OF DIFF. STEM DIRECTIONS.
CALL HOMX
RETURN
9 IF(J11.LT.0)RETURN
C IF P11=-1 NO HOMING
JX=IABS(J7)/10
C JX= STEM DIR. OF BEAM
10 IF(R11.EQ.0)R11=2.9
IZ=0
CC110 RC=0
CC IF(JA.EQ.5)RC=-1.
DO 361 K=1,ITEM
IF(FINDIT(K).LT.0)GO TO 361
C SKIPS NOTES ON WRONG LINE
RDD=RN(L+3)
C L IS IN COMMON
A=RDD
JK=RN(L+5)
JK=JK/10
C /10=NOTE'S STEM DIRECTION
IF(JA.NE.6)GO TO 177
IF(JK.EQ.0)GO TO 361
IF(JK.EQ.JX)GO TO 377
C ARE STEM DIR,S SAME? YES, JUMP
IF(RN(L).LT.8.)GO TO 2377
IF(RN(L+10).NE.0)GO TO 1377
2377 A=(R4+R5)/2.
A=A-RN(L+4)
C AVERAGE HEIGHT OF BEAM LESS HEIGHT OF NOTE
IF(JK.NE.1)A=-A
C IF NOTE STEM DOWN, REVERSE SIGN
IF(A.LE.8.)GO TO 377
C IF DIFF. IS LESS THAN 8 DON'T HOOK BEAM TO STEM.
1377 B=2.44*RSTJ2
C DISX IS NOTE WIDTH( CURRENTLY =2.44)
NN=IABS(J4)
IF(NN.GE.80.AND.NN.LT.180)A=A*.6
C IS IT A MINI?
IF(JK.NE.1)B=-B
C JK+=STEM UP, -=DOWN
RDD=RDD+B
C ADD OR SUB. NOTE WIDTH FROM NOTE POS.
GO TO 177
377 IF(JK.NE.JX)GO TO 361
177 IF(PLACE(R3).GT.0)GO TO 1461
C DO NEXT IF HOMING SLUR
IF(JA.NE.5)GO TO 461
C ALSO CHECK FOR P6 (RT. END OF SLUR)
IF(PLACE(R6).LT.0)GO TO 461
JT=3
NX=4
C POINT TO R6 OR R5
GO TO 2
1461 NX=1
JT=2
C POINT TO R3 OR R4
IZ=-1
2 IF(RN(L+6).LT.10.)GO TO 1
CC IF(JK.EQ.0)GO TO 1
D=2.44
IF(RN(L+6).GE.20.)D=-D
CC IF(JK.LT.0)D=-D
E=ABS(RN(L+4))
C DIDN'T WE DO THIS BEFORE??
IF(E.GE.80.0.AND.E.LT.180.)D=D*.6*RSTFAC(J2)
RDD=RDD+D
1 IF(IZ.GT.0)GO TO 88
3 RJQ(NX)=RDD
IF(R13.GE.0)GO TO 11
CC JT=1
RIS=RN(L+4)
IF(R13.NE.-1.)GO TO 12
A0=2.
IF(R7.LT.0)A0=-A0
A0=A0+RIS
GO TO 80
12 RIZ=RN(L+8)
IF(RIZ.EQ.999.)RIZ=0
RIZ=RIZ+8.
NX=RN(L+7)
A0=MOD(NX,10)
IF(A0.NE.0)A0=(A0-1.)*1.8
C *SPACE FOR EACH TAIL.
13 A0=A0+RIZ
IF(JK.GE.2)A0=-A0
C JK =2 =STEMS DOWN
A0=A0+RIS
C JT CAN BE 2(R4) OR 3(R5)
80 RJQ(JT)=A0
11 IF(JA.EQ.6)GO TO 861
IF(JA.EQ.5)GO TO 361
RETURN
461 IF(JA.EQ.6)GO TO 277
IF(JA.NE.5)GO TO 361
C JUMP IF NOT SLUR
277 IF(PLACE(R6).LT.0)GO TO 561
CC R6=RDD
C ???????
IZ=4
C TO PUT RDD INTO R6 LATER
GO TO 2
861 IF(J7.GE.0)GO TO 361
IF(R9.LE.0)GO TO 661
561 IF(PLACE(R9).LT.0)GO TO 661
IF(J7.LT.0)GO TO 761
C J7=NEG MEANS TREMOLO
IF(R8.NE.0)GO TO 761
IF(R10.EQ.0)GO TO 361
761 IZ=7
C TO PUT RDD INTO R9 LATER
GO TO 2
C R8=0, R10=0 MEANS R9 IS NUMBER OUTSIDE OF BEAM.
661 IF(JA.EQ.5)GO TO 361
IF(J10.EQ.0)GO TO 361
IF(PLACE(R8).LT.0)GO TO 361
C HOMES INNER PARTIAL BEAMS
IZ=6
C TO PUT RDD INTO R8 LATER
GO TO 2
88 RJQ(IZ)=RDD
C PUT A INTO RIGHT PARAM.
361 CONTINUE
END
FUNCTION PLACE(X)
COMMON R2,JA,CENTR,J2,RJQ(8),R11
1 /RMOD/RMODE2,RSET4,IBEAM,NOSET,STEM,STUP,NTC,ENDP,RAD,RDD
PLACE=R11-ABS(RDD-X)
END